{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit MarkScale;

interface

uses
  Windows, Classes, SysUtils, FileUtil, Forms, Controls, ComCtrls, ActnList, ExtCtrls,
  Grids, VisualUtils, Profile, Graphics, Menus, Math, MiscUtils, GraphUtil;

type
  TMarkScaleFrame = class(TFrame)
    actAddItem: TAction;
    actDeleteItem: TAction;
    actAddItemPopup: TAction;
    alScale: TActionList;
    ilScale: TImageList;
    miDeleteItem: TMenuItem;
    miAddItem: TMenuItem;
    pbxScale: TPaintBox;
    pbxTicks: TPaintBox;
    pmScale: TPopupMenu;
    sgScale: TStringGrid;
    tbrScale: TToolBar;
    tbAddItem: TToolButton;
    tbDeleteItem: TToolButton;
    procedure actAddItemExecute(Sender: TObject);
    procedure actAddItemPopupExecute(Sender: TObject);
    procedure actAddItemPopupUpdate(Sender: TObject);
    procedure actAddItemUpdate(Sender: TObject);
    procedure actDeleteItemExecute(Sender: TObject);
    procedure actDeleteItemUpdate(Sender: TObject);
    procedure pbxScaleMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure pbxScaleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure pbxScaleMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure pbxScalePaint(Sender: TObject);
    procedure pbxTicksPaint(Sender: TObject);
    procedure sgScaleDblClick(Sender: TObject);
    procedure sgScaleEditingDone(Sender: TObject);
    procedure sgScaleKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure sgScaleSelectEditor(Sender: TObject; aCol, aRow: Integer;
      var Editor: TWinControl);
    procedure sgScaleSelection(Sender: TObject; aCol, aRow: Integer);
  private
    FScale: TMarkScale;
    FCurrentItem: Integer;
    FDragging: Boolean;
    FDraggingItem: Integer;
    FPopupPoint: TPoint;
    FCancel: Boolean;
    FTicksMargin: Integer;
    FLongTickHeight: Integer;
    FShortTickHeight: Integer;
    function PartToPixel(Part: Single): Integer;
    function PointToPart(const p: TPoint): Single;
    procedure ShowScale;
    function PointToItemBound(const p: TPoint): Integer;
    function FormatPercent(Value: Single): String;
    function AdjustItemBound(Item: Integer; Bound: Single): Single;
    procedure AddItem(Bound: Single);
    function SnapPart100(Part: Single): Single;
    function SnapPart10000(Part: Single): Single;
    procedure UpdateScaleCursor(x, y: Integer);
    { private declarations }
  public
    procedure AfterConstruction; override;
    procedure SetScale(Value: TMarkScale);
    { public declarations }
  end;

implementation

{$R *.lfm}
{$R *.rc}

{ TMarkScaleFrame }

procedure TMarkScaleFrame.AfterConstruction;
begin
  inherited;
  LoadActionImages(alScale);

  pbxTicks.Height := Screen.PixelsPerInch div 3;
  FLongTickHeight := Screen.PixelsPerInch div 8;
  FShortTickHeight := Screen.PixelsPerInch div 16;
  FTicksMargin := Screen.PixelsPerInch div 8;

  pbxScale.Height := Screen.PixelsPerInch div 3;
  sgScale.AutoSizeColumn(1);
  sgScale.AllowOutboundEvents := FALSE;

  pbxScale.BorderSpacing.Left := pbxScale.BorderSpacing.Left + FTicksMargin;
  pbxScale.BorderSpacing.Right := pbxScale.BorderSpacing.Right + FTicksMargin;
  sgScale.BorderSpacing.Left := sgScale.BorderSpacing.Left + FTicksMargin;
  sgScale.BorderSpacing.Right := sgScale.BorderSpacing.Right + FTicksMargin;
end;

procedure TMarkScaleFrame.SetScale(Value: TMarkScale);
begin
  Assert( FScale = nil );
  FScale := Value;
  FCurrentItem := FScale.ItemCount-1;
  ShowScale;
end;

procedure TMarkScaleFrame.pbxScalePaint(Sender: TObject);
var
  i: Integer;
  p: Single;
  Rect: TRect;
  ts: TTextStyle;
begin
  pbxScale.Canvas.Brush.Color := clGray;
  pbxScale.Canvas.Pen.Color := clBlack;
  pbxScale.Canvas.Rectangle(pbxScale.ClientRect);

  Rect.Top := 1;
  Rect.Bottom := pbxScale.ClientHeight-1;

  ts := pbxScale.Canvas.TextStyle;
  ts.Alignment := taCenter;
  ts.Layout := tlCenter;

  for i := 0 to FScale.ItemCount-1 do
  begin
    if FScale.ItemCount > 1 then
      p := i / (FScale.ItemCount-1)
    else
      p := 0;
    pbxScale.Canvas.Brush.Color := HLSToColor(Round(p*85), 128, 230);
    Rect.Left := PartToPixel(FScale.LowerBounds[i]);
    if i < FScale.ItemCount-1 then
      Rect.Right := PartToPixel(FScale.LowerBounds[i+1])
    else
      Rect.Right := PartToPixel(1);
    if Rect.Left < Rect.Right then
    begin
      if i = FCurrentItem then
        pbxScale.Canvas.Rectangle(Rect)
      else
        pbxScale.Canvas.FillRect(Rect);
      Inc(Rect.Left);
      Dec(Rect.Right);
      if Rect.Left < Rect.Right then
        pbxScale.Canvas.TextRect(Rect, 0, 0, FScale.Marks[i], ts);
    end;
  end;
end;

function TMarkScaleFrame.PartToPixel(Part: Single): Integer;
var
  w: Integer;
begin
  Part := Min(Max(Part, 0), 1);
  w := Max(pbxScale.ClientWidth-2, 0);
  Result := Round(Part*w + 1);
end;

procedure TMarkScaleFrame.actAddItemUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := FScale.ItemCount < TMarkScale.MAX_ITEMS;
end;

procedure TMarkScaleFrame.actAddItemExecute(Sender: TObject);
var
  Bound: Single;
begin
  if not FDragging then
  begin
    sgScale.EditorMode := FALSE;

    if FScale.IsEmpty then
      Bound := 0
    else
    begin
      Assert( FCurrentItem <> -1 );
      if FCurrentItem < FScale.ItemCount-1 then
        Bound := (FScale.LowerBounds[FCurrentItem] + FScale.LowerBounds[FCurrentItem+1]) / 2
      else
        Bound := (FScale.LowerBounds[FCurrentItem] + 1) / 2;
      Bound := SnapPart10000(Bound);
    end;

    AddItem(Bound);
  end;
end;

procedure TMarkScaleFrame.actDeleteItemUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := FCurrentItem <> -1;
end;

procedure TMarkScaleFrame.actDeleteItemExecute(Sender: TObject);
var
  Items: TMarkScaleItemList;
begin
  if not FDragging then
  begin
    sgScale.EditorMode := FALSE;

    Items := TMarkScaleItemList.Create;
    try
      FScale.GetItems(Items);

      Items.Delete(FCurrentItem);
      if FCurrentItem > 0 then
        Dec(FCurrentItem);
      if Items.Count > 0 then
        Items[0].LowerBound := 0
      else
        FCurrentItem := -1;

      FScale.SetItems(Items);
    finally
      Items.Free;
    end;

    ShowScale;
  end;
end;

function TMarkScaleFrame.PointToPart(const p: TPoint): Single;
var
  w, h: Integer;
begin
  w := pbxScale.ClientWidth;
  h := pbxScale.ClientHeight;

  if (p.x <= 0) or (p.x >= w-1) or (p.y <= 0) or (p.y >= h-1) or (w <= 2) then
    Result := -1
  else
    Result := (p.x-1) / (w-2);
end;

type
  THackedStringGrid = class(TStringGrid) end;

procedure TMarkScaleFrame.ShowScale;
var
  i: Integer;
begin
  pbxScale.Invalidate;

  sgScale.EditorMode := FALSE;
  sgScale.RowCount := FScale.ItemCount+1;
  for i := 0 to FScale.ItemCount-1 do
  begin
    sgScale.Cells[0, i+1] := FScale.Marks[i];
    sgScale.Cells[1, i+1] := FormatPercent(FScale.LowerBounds[i]);
  end;

  sgScale.Row := FCurrentItem+1;
  THackedStringGrid(sgScale).SelectEditor; { Without this, <Enter> doesn't show the editor
    after a single mark has been added. }
end;

procedure TMarkScaleFrame.pbxTicksPaint(Sender: TObject);
var
  n, x, w: Integer;
  s: String;
  Size: TSize;
begin
  pbxTicks.Canvas.Pen.Color := clWindowText;
  pbxTicks.Canvas.Font.Color := clWindowText;
  pbxTicks.Canvas.Brush.Style := bsClear;

  w := pbxTicks.Width - 2*FTicksMargin - 1;
  n := 0;
  while n <= 100 do
  begin
    x := Round(n/100*w) + FTicksMargin;
    pbxTicks.Canvas.MoveTo(x, pbxTicks.ClientHeight-1);
    if n mod 10 = 0 then
    begin
      pbxTicks.Canvas.LineTo(x, pbxTicks.ClientHeight - FLongTickHeight);
      s := IntToStr(n);
      Size := pbxTicks.Canvas.TextExtent(s);
      pbxTicks.Canvas.TextOut(x - Size.cx div 2,
        pbxTicks.ClientHeight - FLongTickHeight - Size.cy - 1, s);
    end
    else
      pbxTicks.Canvas.LineTo(x, pbxTicks.ClientHeight - FShortTickHeight);
    Inc(n, 5);
  end;
end;

procedure TMarkScaleFrame.sgScaleDblClick(Sender: TObject);
var
  p: TPoint;
begin
  p := sgScale.ScreenToClient(Mouse.CursorPos);
  if sgScale.MouseToGridZone(p.x, p.y) = gzNormal then
    sgScale.EditorMode := TRUE;
end;

function TMarkScaleFrame.AdjustItemBound(Item: Integer;
  Bound: Single): Single;
var
  LeftBound, RightBound: Single;
begin
  if Item = 0 then
    Result := 0
  else
  begin
    LeftBound := FScale.LowerBounds[Item-1];
    if Item < FScale.ItemCount-1 then
      RightBound := FScale.LowerBounds[Item+1]
    else
      RightBound := 1;
    Result := Min(Max(Bound, LeftBound), RightBound);
  end;
end;

procedure TMarkScaleFrame.pbxScaleMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
var
  Part: Single;
  Items: TMarkScaleItemList;
begin
  UpdateScaleCursor(X, Y);
  if not (ssLeft in Shift) then
    FDragging := FALSE;
  if FDragging then
  begin
    Part := PointToPart(Point(X, Y));
    if Part <> -1 then
    begin
      if ssShift in Shift then
        Part := SnapPart10000(Part)
      else
        Part := SnapPart100(Part);
      Part := AdjustItemBound(FDraggingItem, Part);

      Items := TMarkScaleItemList.Create;
      try
        FScale.GetItems(Items);
        Items[FDraggingItem].LowerBound := Part;
        FScale.SetItems(Items);
      finally
        Items.Free;
      end;

      sgScale.Cells[1, FDraggingItem+1] := FormatPercent(FScale.LowerBounds[FDraggingItem]);
      pbxScale.Invalidate;
    end;
  end;
end;

function TMarkScaleFrame.PointToItemBound(const p: TPoint): Integer;
var
  Part, PartLeft, PartRight: Single;
  i: Integer;
begin
  Result := -1;
  Part := PointToPart(p);
  if Part <> -1 then
  begin
    PartLeft := PointToPart(Point(p.x-2, p.y));
    if PartLeft = -1 then
      PartLeft := 0;

    PartRight := PointToPart(Point(p.x+2, p.y));
    if PartRight = -1 then
      PartRight := 1;

    for i := FScale.ItemCount-1 downto 0 do
      if (FScale.LowerBounds[i] >= PartLeft) and (FScale.LowerBounds[i] <= PartRight) then
      begin
        Result := i;
        Break;
      end;
  end;
end;

procedure TMarkScaleFrame.pbxScaleMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  Item: Integer;
  Part: Single;
begin
  sgScale.EditorMode := FALSE;

  Item := PointToItemBound(Point(X, Y));
  if (Item > 0) and not FDragging and (Button = mbLeft) then
  begin
    FDraggingItem := Item;
    FDragging := TRUE;
  end;

  if not FDragging then
  begin
    Part := PointToPart(Point(X, Y));
    if Part <> -1 then
    begin
      Item := FScale.PartRightToItemIndex(Part);
      if Item <> FCurrentItem then
      begin
        FCurrentItem := Item;
        ShowScale;
      end;
      if Button = mbRight then
      begin
        FPopupPoint := Point(X, Y);
        pmScale.PopUp;
      end;
    end;
  end;

  sgScale.SetFocus;
end;

procedure TMarkScaleFrame.pbxScaleMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FDragging := FALSE;
  UpdateScaleCursor(X, Y);
end;

procedure TMarkScaleFrame.sgScaleSelectEditor(Sender: TObject; aCol,
  aRow: Integer; var Editor: TWinControl);
begin
  if (aCol = 1) and (aRow = 1) then
    Editor := nil
  else
    Editor := sgScale.EditorByStyle(cbsAuto);
end;

procedure TMarkScaleFrame.sgScaleSelection(Sender: TObject; aCol, aRow: Integer);
begin
  FCurrentItem := ARow - 1;
  pbxScale.Invalidate;
end;

procedure TMarkScaleFrame.sgScaleEditingDone(Sender: TObject);
var
  s: String;
  Items: TMarkScaleItemList;
  Bound, f: Single;
begin
  if FCurrentItem <> -1 then
  begin
    if FCancel then
      s := FScale.Marks[FCurrentItem]
    else
      s := CollapseSpaces(sgScale.Cells[0, FCurrentItem+1]);
    sgScale.Cells[0, FCurrentItem+1] := s;

    Bound := FScale.LowerBounds[FCurrentItem];
    if not FCancel and TryStrToFloat(CommaToDot(sgScale.Cells[1, FCurrentItem+1]), f) then
      Bound := AdjustItemBound(FCurrentItem, SnapPart10000(f/100));
    sgScale.Cells[1, FCurrentItem+1] := FormatPercent(Bound);

    if not FCancel then
    begin
      Items := TMarkScaleItemList.Create;
      try
        FScale.GetItems(Items);

        Items[FCurrentItem].Mark := s;
        Items[FCurrentItem].LowerBound := Bound;

        FScale.SetItems(Items);
      finally
        Items.Free;
      end;

      pbxScale.Invalidate;
    end;
  end;
end;

procedure TMarkScaleFrame.sgScaleKeyDown(Sender: TObject;
  var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_ESCAPE:
      begin
        Key := 0;

        FCancel := TRUE;
        try
          sgScale.EditorMode := FALSE;
        finally
          FCancel := FALSE;
        end;

        sgScale.SetFocus;
      end;
    VK_F2:
      begin
        if Shift = [] then
        begin
          Key := 0;
          actAddItem.Execute;
        end;
      end;
    VK_DELETE:
      begin
        if Shift = [] then
        begin
          Key := 0;
          actDeleteItem.Execute;
        end;
      end;
  end;
end;

function TMarkScaleFrame.FormatPercent(Value: Single): String;
begin
  Result := ConvertFloatToString(Value*100, 2, GetUiDecimalSeparator, TRUE);
end;

procedure TMarkScaleFrame.AddItem(Bound: Single);
var
  Items: TMarkScaleItemList;
  Item: TMarkScaleItem;
begin
  if FScale.ItemCount < TMarkScale.MAX_ITEMS then
  begin
    Items := TMarkScaleItemList.Create;
    try
      FScale.GetItems(Items);

      if Items.Count = 0 then
      begin
        Items.AddSafely(TMarkScaleItem.Create);
        FCurrentItem := 0;
      end
      else
      begin
        Assert( FCurrentItem <> -1 );

        Bound := Max(Bound, FScale.LowerBounds[FCurrentItem]);
        if FCurrentItem < FScale.ItemCount-1 then
          Bound := Min(Bound, FScale.LowerBounds[FCurrentItem+1])
        else
          Bound := Min(Bound, 1);

        Item := TMarkScaleItem.Create;
        Items.InsertSafely(FCurrentItem+1, Item);
        Item.LowerBound := Bound;

        Inc(FCurrentItem);
      end;

      FScale.SetItems(Items);
    finally
      Items.Free;
    end;

    ShowScale;
    sgScale.SetFocus;
  end;
end;

procedure TMarkScaleFrame.actAddItemPopupUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := FScale.ItemCount < TMarkScale.MAX_ITEMS;
end;

procedure TMarkScaleFrame.actAddItemPopupExecute(Sender: TObject);
var
  Part: Single;
  p: TPoint;
begin
  if not FDragging then
  begin
    sgScale.EditorMode := FALSE;

    p := Point(FPopupPoint.x+2, FPopupPoint.y);
    Part := PointToPart(p);
    if Part <> -1 then
    begin
      if ShiftDown then
        Part := SnapPart10000(Part)
      else
        Part := SnapPart100(Part);
      AddItem(Part);
    end;
  end;
end;

function TMarkScaleFrame.SnapPart100(Part: Single): Single;
begin
  Result := Min(Max(Round(Part*100)/100, 0), 1);
end;

function TMarkScaleFrame.SnapPart10000(Part: Single): Single;
begin
  Result := Min(Max(Round(Part*10000)/10000, 0), 1);
end;

procedure TMarkScaleFrame.UpdateScaleCursor(x, y: Integer);
begin
  if FDragging or (PointToItemBound(Point(x, y)) > 0) then
    pbxScale.Cursor := crHSplit
  else
    pbxScale.Cursor := crHandPoint;
end;

end.

